perm filename LINEW.F4[PIC,LCS]3 blob
sn#251267 filedate 1976-12-05 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE LINES(I)
C00009 ENDMK
Cā;
SUBROUTINE LINES(I)
COMMON/FU/FUJ(512),JJX,RDIV,ADML/MEDGE/MC,MD,RMC,MMD
COMMON/DRW/JDRW(2000) /JEXCH/JEXCH
EQUIVALENCE(KNT,JDRW(1))
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
DATA IFLIP/-1/,RDIV/.5/,FUJ(1)/99./
IF(JEXCH)CALL EXCH(JA,JB)
C TYPE ADD 100 TO 'REV' TO EXCH X AND Y COORDINATES.
CALL SWITCH
C REVERSE OR INVERT (IN 'SWITCH') HAPPEN BEFORE DISTORTION OR ROTATE.
IF(FUJ(1).EQ.99)GO TO 31
RX=JA*RMC+1
IF(RX.GT.512.)RX=512.
IF(ADML.GE.0)GO TO 32
JB=JB+MMD*FUJ(IFIX(RX))
C 'CENTR' IS MULT FOR ADDING! (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
GO TO 31
32 NY=JB-MMD
JB=MMD+NY*FUJ(IFIX(RX))
31 IF(ROT.LE.1)GO TO 9
RX=JA
RY=JB
AX=ATAN2(RY,RX)*57.29578
HYP=SQRT(RX**2+RY**2)
RT=ROT+AX
JA=HYP*COSD(RT)
JB=HYP*SIND(RT)
GO TO 10
9 IF(ROT.GT.0)CALL EXCH(JA,JB)
10 JA=JA+JX
JB=JB+JY
C IF ROT.GE.0 ROTATE 90 DEG. TO LEFT
M=JA
N=JB
IF(PLT)GO TO 1
6 M=M-JAR
N=N-JBR
CC2 TYPE 20,M,N,JX,JY
20 FORMAT(4I6)
IF(I.EQ.3)GO TO 3
CALL RVECT(M,N)
5 JAR=JA
JBR=JB
RETURN
3 CALL RIVECT(M,N)
GO TO 5
CC1 TYPE 20,M,N,JX,JY
1 IF(PLT.EQ.-2)GO TO 4
CALL PLOT(M,N,I)
RETURN
4 IFLIP=-IFLIP
IF(I.EQ.3)GO TO 7
IF(KNT.GE.200.OR.IFLIP)RETURN
GO TO 70
7 IF(JDRW(KNT).GT.100000000)GO TO 71
70 KNT=KNT+1
71 M=M/8
N=N/8
IF(M.NE.KM)GO TO 56
IF(IABS(N-KN).GT.1)GO TO 55
IF(N.EQ.KN)GO TO 59
57 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
GO TO 58
56 IF(N.NE.KN)GO TO 55
IF(IABS(M-KM).LE.1)GO TO 57
GO TO 55
59 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
RETURN
55 IF(I.NE.3)GO TO 11
KM=10000
GO TO 8
11 IF(M-KM.NE.LM.OR.N-KN.NE.LN)GO TO 8
IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
8 LN=N-KN
LM=M-KM
KM=M
KN=N
58 M=(M-50)*10000
N=N-50
IF(M)M=10000000-M
IF(N)N=1000-N
IF(I.EQ.3)M=M+100000000
JDRW(KNT)=M+N
IF(JDRW(KNT).EQ.0)KNT=KNT-1
END
CC SUBROUTINE EXCH(J,K)
CC I=J
CC J=K
CC K=I
CC END
CC SUBROUTINE JZERO
CC COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
CC 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
CC JAR=0
CC JBR=0
CC END
SUBROUTINE DSTORT(JPL)
COMMON/MEDGE/MC,MD,RMC,MMD/FU/FUJ(512),JJX,RDIV,ADML
MMD=(MD/JPL)*RDIV
IF(ADML)MMD=RDIV*(MD/JPL)
C 'CENTR' IS MULT FOR ADDING! (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
RMC=MC
RMC=511./(RMC/JPL)
END
SUBROUTINE INVIS(MA,MB,MC,MD,N)
DIMENSION LL(100)
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
CALL JZERO
NA=MA/3
NB=MB/3
NC=MC/3
ND=MD/3
IF(N.EQ.0)N=-1
IF(N)CALL DPYSET(2,LL,100)
N=1
CALL JZERO
CALL DPYBRT(2)
1 CALL AIVECT(-380,-200)
JA=NA
JB=NC
CALL LINES(3)
JB=NC
JA=NB
CALL LINES(2)
JB=ND
JA=NB
CALL LINES(2)
JA=NA
JB=ND
CALL LINES(2)
JA=NA
JB=NC
CALL LINES(2)
CALL JZERO
6683 CALL DPYOUT(2)
END
CC SUBROUTINE SWITCH
CC COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
CC 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
CC IF(REV.NE.0)JA=JREV-JA
CC IF(RINV.NE.0)JB=JINV-JB
CC END
SUBROUTINE DPFUN(JFU)
COMMON/FU/FUJ(512),JJX,RDIV,ADML/DRW/LIST(2000)
13 IF(JFU.NE.' ')GO TO 19
C AFTER FILE NAME IS GIVEN, 'FUNC' ALONE GETS IT BACK.
IF(KFU.EQ.0)GO TO 1
JFU=KFU
TYPE 18,X,JFU
GO TO 19
14 FORMAT(' FUNC FILE NAME? ',$)
15 FORMAT(8F)
CC83 FORMAT(A5)
1 TYPE 14
ACCEPT 18,JFU
IF(JFU.NE.' ')GO TO 19
FUJ(1)=99.
C A BLANK DELETES FUNC ACTION.
RETURN
19 KFU=JFU
CALL FORNAM(JFU,'FUN')
CC19 REWIND 1
CC CALL IFILE(1,JFU)
DO 17 K=1,3
17 READ(1,18)A,B,B
18 FORMAT(3A5)
16 READ(1,15)A,B
IF(B.NE.520.0)GO TO 16
READ(1,15)FUJ
CALL DPYSET(3,LIST,500)
CALL ALINE(306,300,476,300)
CALL ALINE(306,215,306,385)
CC CALL AIVECT(0,0)
KY=FUJ(1)*85.0+300.
CALL AIVECT(306,KY)
DO 32 K=2,512,3
KY2=FUJ(K)*85.0+300.
CALL RVECT(1,KY2-KY)
32 KY=KY2
CALL DPYOUT(3)
END
SUBROUTINE DD
COMMON/DRW/JDRW(2000)
3 REWIND 21
6 K=JDRW(1)+1
IF(K.LE.201)GO TO 5
JDRW(1)=200
K=201
5 WRITE(21,120)K
120 FORMAT(' 9999 1 ',I4,' 0 0 0 0 0 0 0 0')
J=7
L=8
DO 12 K=1,JDRW(1),8
IF(K+J.LT.JDRW(1))GO TO 12
J=JDRW(1)-K
L=J+1
12 WRITE(21,11)L,(JDRW(N),N=K,K+J)
CALL EXIT
11 FORMAT(' 9999',I3,8I10)
END